home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / tvtoys04.zip / FONTDLG.PAS < prev    next >
Pascal/Delphi Source File  |  1993-12-18  |  10KB  |  335 lines
  1. (***************************************************************************
  2.   FontDlg unit
  3.   Font selection dialog
  4.   PJB November 3, 1993, Internet mail to d91-pbr@nada.kth.se
  5.   Copyright 1993, All Rights Reserved
  6.   Free source, use at your own risk.
  7.   If modified, please state so if you pass this around.
  8.  
  9. ***************************************************************************)
  10. unit FontDlg;
  11.  
  12. {$I toyCfg}
  13.  
  14. {$B-,O+,X+}
  15.  
  16. interface
  17.  
  18.   uses
  19.     Dos,
  20.     App, Dialogs, Drivers, MsgBox, Objects, StdDlg, Validate, Views,
  21.     toyPrefs, {$I hcFile}
  22.     DblStr, FontFiles, toyUtils, TVVideo, TVUtils, Video;
  23.  
  24.  
  25.   type
  26.     PSelFontDialog = ^TSelFontDialog;
  27.     TSelFontDialog =
  28.       object (TDialog)
  29.         constructor Init;
  30.         procedure HandleEvent(var Event:TEvent); virtual;
  31.       end;
  32.  
  33.  
  34.   procedure ReloadLastFont;
  35.   (* Where do I put this? *)
  36.   procedure ReloadFontAndPalette;
  37.  
  38.   procedure LoadResFont(ResFile:PResourceFile; const FontRes:String);
  39.   procedure LoadDiskFont(const FileName:String);
  40.  
  41.   procedure ScanFontFiles(const Path:String; Proc:ScanProcedure);
  42.   function  SelectFontDialog(const FontPath:String; ResFile:PResourceFile):Boolean;
  43.   function  SelectFont(List:PDblStringCollection; var Name:String):Boolean;
  44.  
  45.   var
  46.     (* Last disk font loaded or font resource key used *)
  47.     LastFontNameLoaded : PathStr;
  48.     (* Last resource file used, must be open *)
  49.     LastFontResourceFile : PResourceFile;
  50.  
  51.  
  52. (***************************************************************************
  53. ***************************************************************************)
  54. implementation
  55.  
  56.   uses
  57.     TVPal;
  58.  
  59.  
  60.   (*******************************************************************
  61.     Reloads both the palette and the last font
  62.   *******************************************************************)
  63.   procedure ReloadFontAndPalette;
  64.   begin
  65.     ReloadLastFont;
  66.     ReloadPalette;
  67.   end;
  68.  
  69.  
  70. (***************************************************************************
  71. ***************************************************************************)
  72.  
  73.   (*******************************************************************
  74.     Load a disk font
  75.   *******************************************************************)
  76.   procedure LoadDiskFont(const FileName:String);
  77.     var
  78.       Font : TFontFile;
  79.   begin
  80.     if Font.Read(FileName) then
  81.     begin
  82.       Font.Display;
  83.       LastFontNameLoaded:=FExpand(FileName);
  84.       LastFontTypeUsed:=lfDiskFont;
  85.     end;
  86.   end;
  87.  
  88.  
  89.   (*******************************************************************
  90.     Load a font from a resource file
  91.   *******************************************************************)
  92.   procedure LoadResFont(ResFile:PResourceFile; const FontRes:String);
  93.     var
  94.       P : PFontFile;
  95.   begin
  96.     P:=PFontFile(ResFile^.Get(FontRes));
  97.     if P<>Nil then
  98.     begin
  99.       P^.Display;
  100.       Dispose(P, Done);
  101.     end;
  102.  
  103.     LastFontNameLoaded:=FontRes;
  104.     LastFontResourceFile:=ResFile;
  105.     LastFontTypeUsed:=lfResourceFont;
  106.   end;
  107.  
  108.  
  109.   (*******************************************************************
  110.     Reload last font loaded from disk
  111.   *******************************************************************)
  112.   procedure ReloadLastDiskFont;
  113.     var
  114.       Font : TFontFile;
  115.   begin
  116.     if LastFontNameLoaded<>'' then
  117.       if Font.DoRead(LastFontNameLoaded) then
  118.         Font.Display;
  119.   end;
  120.  
  121.  
  122.   (*******************************************************************
  123.     Reload last font from its source
  124.   *******************************************************************)
  125.   procedure ReloadLastFont;
  126.   begin
  127.     case TVVideo.LastFontTypeUsed of
  128.      {$IFDEF DiskFonts}
  129.       lfDiskFont: ReloadLastDiskFont;
  130.      {$ENDIF}
  131.      {$IFDEF ResFonts}
  132.       lfResourceFont: LoadResFont(LastFontResourceFile, LastFontNameLoaded);
  133.      {$ENDIF}
  134.     end;
  135.   end;
  136.  
  137.  
  138. (***************************************************************************
  139. ***************************************************************************)
  140.  
  141.   (*******************************************************************
  142.     Look for font files in a directory
  143.   *******************************************************************)
  144.   procedure ScanFontFiles;
  145.     var
  146.       f : TFontFile;
  147.   begin
  148.     Notice('', ^M^M^C'Searching for font files...');
  149.     f.DiskScan(Path, Proc);
  150.     NoNotice;
  151.   end;
  152.  
  153.  
  154. (***************************************************************************
  155. ***************************************************************************)
  156.  
  157.   (*******************************************************************
  158.     Here we store the font files found
  159.   *******************************************************************)
  160.   var
  161.     FontList  : PDblStringCollection;
  162.  
  163.   (*******************************************************************
  164.     Called by ScanFontFiles
  165.   *******************************************************************)
  166.   procedure SelectFiles(Points:Integer; const Desc, FileName:String); far;
  167.   begin
  168.     if (VideoType=VGA) or (Points<=14) then
  169.       FontList^.Insert(NewDoubleStr(Desc, FileName));
  170.   end;
  171.  
  172.  
  173.   (*******************************************************************
  174.     Let user select a font
  175.     Define DiskFonts to search for disk fonts
  176.     Define ResFonts to search in the resource file parameter
  177.     You can define both to search in both...
  178.  
  179.     The resource file must contain a StringCollection resource saved
  180.     under the key FONTLIST (see TOYPREFS) with the keys to the
  181.     TFontFiles available in the stream. RESTEST contains an example.
  182.   *******************************************************************)
  183.   function SelectFontDialog(const FontPath:String; ResFile:PResourceFile):Boolean;
  184.     var
  185.       FontChosen : String;
  186.       ResFonts   : PStringCollection;
  187.  
  188.     procedure AddFont(const FontRes:PString); far;
  189.       var
  190.         P : PFontFile;
  191.     begin
  192.       P:=PFontFile(ResFile^.Get(FontRes^));
  193.       if P<>Nil then
  194.       begin
  195.         FontList^.Insert(NewDoubleStr(P^.Desc, FontRes^));
  196.         Dispose(P, Done);
  197.       end;
  198.     end;
  199.  
  200.     procedure Load;
  201.     begin
  202.       LoadDiskFont(AddBackslash(FontPath)+FontChosen);
  203.     end;
  204.  
  205.   begin
  206.     SelectFontDialog:=False;
  207.     New(FontList, Init(20, 10));
  208.  
  209.    {$IFDEF DiskFonts}
  210.     ScanFontFiles(FontPath, SelectFiles);
  211.    {$ENDIF}
  212.  
  213.    {$IFDEF ResFonts}
  214.     if ResFile<>Nil then
  215.     begin
  216.       ResFonts:=PStringCollection(ResFile^.Get(toyFontListKey));
  217.       ResFonts^.ForEach(@AddFont);
  218.       Dispose(ResFonts, Done);
  219.     end;
  220.    {$ENDIF}
  221.  
  222.     if FontList^.Count=0 then
  223.       MessageBox(^C'No font files found!', Nil, mfError+mfOKButton)
  224.     else
  225.       if SelectFont(FontList, FontChosen) then
  226.       begin
  227.        {$IFDEF DiskFonts}
  228.          {$IFDEF ResFonts}
  229.           if (Length(FontChosen)>3) and
  230.              MemComp(FontChosen[Length(FontChosen)-3],
  231.                      toyFontExt[1], Length(toyFontExt)) then
  232.             Load
  233.           else
  234.          {$ELSE}
  235.           Load;
  236.          {$ENDIF}
  237.        {$ENDIF}
  238.        {$IFDEF ResFonts}
  239.         LoadResFont(ResFile, FontChosen);
  240.        {$ENDIF}
  241.  
  242.         SelectFontDialog:=True;
  243.       end;
  244.  
  245.     Dispose(FontList, Done);
  246.   end;
  247.  
  248.  
  249. (***************************************************************************
  250. ***************************************************************************)
  251.  
  252.   (*******************************************************************
  253.     This code generated by Dialog Design 4.0
  254.   *******************************************************************)
  255.   constructor TSelFontDialog.Init;
  256.     var
  257.       R : TRect;
  258.       Control : PView;
  259.   begin
  260.     R.Assign(15, 2, 64, 21);
  261.     inherited Init(R, 'Select a Font');
  262.     Options := Options or ofCentered;
  263.  
  264.     R.Assign(44, 3, 45, 15);
  265.     Control := New(PScrollBar, Init(R));
  266.     Insert(Control);
  267.  
  268.     R.Assign(4, 3, 44, 15);
  269.     Control := New(PSortedListBox, Init(R, 1, PScrollbar(Control)));
  270.     Control^.HelpCtx := hctoyFontListbox;
  271.     Insert(Control);
  272.  
  273.     R.Assign(3, 2, 8, 3);
  274.     Insert(New(PLabel, Init(R, '~F~onts', Control)));
  275.  
  276.     R.Assign(7, 16, 17, 18);
  277.     Control := New(PButton, Init(R, 'O~K~', cmOK, bfDefault));
  278.     Control^.HelpCtx := hcOK;
  279.     Insert(Control);
  280.  
  281.     R.Assign(19, 16, 29, 18);
  282.     Control := New(PButton, Init(R, 'Cancel', cmCancel, bfLeftJust));
  283.     Control^.HelpCtx := hcCancel;
  284.     Insert(Control);
  285.  
  286.     R.Assign(31, 16, 41, 18);
  287.     Control := New(PButton, Init(R, 'Help', cmHelp, bfNormal));
  288.     Control^.HelpCtx := hctoyFontDialogHelp;
  289.     Insert(Control);
  290.  
  291.     SelectNext(False);
  292.   end;
  293.  
  294.  
  295.   (*******************************************************************
  296.     Double click in list box acts like Enter key
  297.   *******************************************************************)
  298.   procedure TSelFontDialog.HandleEvent;
  299.   begin
  300.     inherited HandleEvent(Event);
  301.     if (Event.What=evBroadcast) and (Event.Command=cmListItemSelected) then
  302.       EndModal(cmOK);
  303.   end;
  304.  
  305.  
  306. (***************************************************************************
  307. ***************************************************************************)
  308.  
  309.   var
  310.     ListRec :
  311.       record
  312.         List      : PDblStringCollection;
  313.         Selection : Word;
  314.       end;
  315.  
  316.   (*******************************************************************
  317.     Execute font selection dialog
  318.   *******************************************************************)
  319.   function SelectFont(List:PDblStringCollection; var Name:String):Boolean;
  320.   begin
  321.     SelectFont:=False;
  322.     ListRec.List:=List;
  323.     if Application^.ExecuteDialog(New(PSelFontDialog, Init), @ListRec)<>cmCancel then
  324.     begin
  325.       Name:=PString(ListRec.List^.At2nd(ListRec.Selection))^;
  326.       SelectFont:=True;
  327.     end;
  328.   end;
  329.  
  330.  
  331.     (*******************************************************************
  332.     *******************************************************************)
  333.  
  334. end.
  335.